unit actions;

interface

uses
  Forms,
  blcksock,
  ComCtrls,
  Classes;

procedure InitFSPlugin; stdcall; export;
function GetTab(ATabSheet: TTabSheet; AAppHandle: Cardinal): TFormClass; stdcall; export;
procedure BeforeDispatch(var ADirectory, AUri, AOutPut: string;
  AHeaders: TStrings; var AResultType: Byte; ASocket: TTCPBlockSocket); stdcall;

var
  gUsers: TStringList;
  gAppHandle: Cardinal;

implementation

uses
  SysUtils,
  StrUtils,
  DateUtils,
  User,
  dlgAuthForm;

const
  cExpireSession = 1800; //in seconds

function GetTab(ATabSheet: TTabSheet; AAppHandle: Cardinal): TFormClass;
begin
  ATabSheet.Caption := 'Authentication';
  Application.Handle := AAppHandle;
  Result := TAuthForm;
end;

function GetCss: string;
begin
  Result :=
  '<style>' +
  'table {' +
  ' border-width: 2px;' +
  ' border-color: #000000; ' +
  ' background-color: #000099; ' +
  ' } ' +
  'td {' +
	'  font-family:	Verdana, Helvetica, Arial, Sans-Serif;' +
  '  padding: 5px 5px 5px 5px; '+
  '  background-color: #003399; ' +
  '  color: #FFFFFF; ' +
  ' } ' +
  'td.title {' +
	'  font-family:	Verdana, Helvetica, Arial, Sans-Serif;' +
  '  color: #FFFFFF; ' +
  '  background-color: #003399; ' +
  ' } ' +
  'body {' +
	'  font-family:	Verdana, Helvetica, Arial, Sans-Serif;' +
  ' } ' +
  '</style>';
end;


function GetLoginForm(AFormerPath: string): string;
begin
  Result :=
    '<html><head>' +
    '<title>File Sharer Login window</Title>' +
    getCss +
    '</head>' + #13#10 +
    '<body>' +
    '  <center>' +
    '  <br><br><br><br><br>' +
    '  Please, login to your FileSharer Acount<br><br>' +
    '  <table cellspacing=0 cellpadding=0>' +
    '  <form name="login" action="/login" method=POST>' +
    '  <input type=hidden name="FORMERPATH" value="' + AFormerPath + '">' +
    '  <tr>' +
    '  <td colspan = 2 align="center" class="title"><b>Login</b></td>' +
    '  </tr>' +
    '  <tr>' +
    '  <td>User:</td><td><input type=text size=20 name="USER"></td>' +
    '  </tr>' +
    '  <tr>' +
    '  <td>Pass:</td><td><input type=password size=20 name="PASS"></td>' +
    '  </tr>' +
    '  <tr>' +
    '  <td>&nbsp;</td><td><input type=submit></td>' +
    '  </tr>' +
    '  </form>' +
    '  </table>' +
    '  </center>' +
    '</body>' +
    '</html>';
end;

procedure InitFSPlugin;
begin
  (* This procedure must be included in every FileSharer plugin. *)
  (* And must be empty. *)
end;

function HttpDecode(const AStr: String): string;
var
  Sp, Rp, Cp: PChar;
  S: String;
begin
  SetLength(Result, Length(AStr));
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do
  begin
    case Sp^ of
      '+': Rp^ := ' ';
      '%': begin
             // Look for an escaped % (%%) or %<hex> encoded character
             Inc(Sp);
             if Sp^ = '%' then
               Rp^ := '%'
             else
             begin
               Cp := Sp;
               Inc(Sp);
               if (Cp^ <> #0) and (Sp^ <> #0) then
               begin
                 S := '$' + Cp^ + Sp^;
                 Rp^ := Chr(StrToInt(S));
               end;
             end;
           end;
    else
      Rp^ := Sp^;
    end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

function ExtractValue(AText, AVariable: string): string;
begin
  Result := '';
  if Pos(AVariable, AText) = 0 then
    Exit;
  Result := Copy(AText, Pos(AVariable, AText), Length(AText) - (Pos(AVariable, AText) - 1));
  if Pos('&', Result) > 0 then
    Result := Copy(Result, 0, Pos('&', Result) - 1);
  Result := Copy(Result, Pos('=', Result) + 1, Length(Result) - (Pos('=', Result) - 1));
  Result := HttpDecode(Result);
end;

function IsLogged(AIp: string): Boolean;
var
  lTime: string;
begin
  lTime := gUsers.Values[AIP];
  Result := lTime <> '';
  if Result then
  begin
    Result := IncSecond(StrToTime(lTime), cExpireSession) >= StrToTime(TimeToStr(Now));
    if Result then
      gUsers.Values[AIP] := TimeToStr(Now);
  end;
end;

procedure BeforeDispatch(var ADirectory, AUri, AOutPut: string;
  AHeaders: TStrings; var AResultType: Byte; ASocket: TTCPBlockSocket); stdcall;
(* If AResultType is 255 then this executes allowing the next beforedispatch
   continues executing. *)
var
  lUri: string;
  lUser: string;
  lPass: string;
  lPath: string;
  lHead: string;

begin
  lUri := UpperCase(AUri);
  lHead := AHeaders.Text;
  lHead := AnsiReplaceStr(lHead, #13, '');
  lHead := AnsiReplaceStr(lHead, #10, '');

  lUri := UpperCase(AUri);
  (* Ignore images *)
  if Pos('/IMAGES/', lUri) > 0 then
    exit
  else
  (* Process request *)
  if Pos('/LOGIN', lUri) > 0 then
  begin
    lPath := ExtractValue(lHead, 'FORMERPATH=');
    if UpperCase(lPath) = '/LOGIN' then
      lPath := '/';
    lUser := ExtractValue(lHead, 'USER=');
    lPass := ExtractValue(lHead, 'PASS=');
    AHeaders.Clear;
    if TUsers.UserEnabled(lUser, lPass) then
    begin
      gUsers.Values[ASocket.GetRemoteSinIP] := TimeToStr(Now);
      AUri := lPath;
    end
    else
    begin
      (* Shows login dialog *)
      AHeaders.Clear;
      AOutPut := GetLoginForm(lUri);
      (* Stops execution of next statements *)
      AResultType := 0;
    end;
  end
  else
  if not IsLogged(ASocket.GetRemoteSinIP) then
  begin
    (* Shows login dialog *)
    AHeaders.Clear;
    AOutPut := GetLoginForm(lUri);
    (* Stops execution of next statements *)
    AResultType := 0;
  end
  else
    AResultType := 255;
end;

initialization
  gUsers := TStringList.Create;

finalization
  gUsers.Free;

end.
